home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FishMarket 1.0
/
FishMarket v1.0.iso
/
fishies
/
551-575
/
disk_556
/
scheme2c
/
scheme-src.lzh
/
scrt
/
scrt7.sc
< prev
next >
Wrap
Text File
|
1991-10-11
|
16KB
|
478 lines
;;; SCHEME->C Runtime Library
;* Copyright 1989 Digital Equipment Corporation
;* All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions. Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software. Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software. Correspondence should be provided to Digital at:
;*
;* Director of Licensing
;* Western Research Laboratory
;* Digital Equipment Corporation
;* 100 Hamilton Avenue
;* Palo Alto, California 94301
;*
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.
;*
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.
(module scrt7 (top-level))
(define-external UNDEFINED "sc" "undefined")
(define-c-external (SSCANF pointer pointer pointer pointer) int "sscanf")
(define-c-external (GCVT double int pointer) int "gcvt")
;;; 7.1.1. Lexical Structure
;;; The following global values define tokens used to denote special symbols
;;; which are returned by TOKEN. They must be computed at run-time as they
;;; cannot use READCONSTANT.
(define TOKEN-LEFT-PAREN (cons 'left-paren '()))
(define TOKEN-RIGHT-PAREN (cons 'right-paren '()))
(define TOKEN-QUOTE (cons 'quote '()))
(define TOKEN-QUASIQUOTE (cons 'quasiquote '()))
(define TOKEN-UNQUOTE-SPLICING (cons 'unquote-splicing '()))
(define TOKEN-UNQUOTE (cons 'unquote '()))
(define TOKEN-PERIOD (cons 'period '()))
(define TOKEN-VECTOR (cons 'vector '()))
;;; In order to read characters faster from the current input port, the
;;; methods are cached here on entry to this module by READ-DATUM.
(define PEEK-CHAR-PORT '()) ;;; Method to inspect a char
(define READ-CHAR-PORT '()) ;;; Method to read a char
(define (NEXT-CHAR)
(let ((char (read-char-port)))
(if (eof-object? char)
(error 'READ "Unexpected end-of-file")
char)))
(define-in-line (CHAR-WHITESPACE? char)
((lap (char)
(BOOLEAN (OR (EQ char (C_CHAR "040"))
(AND (GTE char (C_CHAR "011"))
(LTE char (C_CHAR "015")))))) char))
(define-in-line (CHAR->INTEGER c) ((lap (c) (C_FIXED (CHAR_C c))) c))
(define-in-line (SPECIAL-INITIAL? char)
(memq char '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\~ #\_ #\^)))
(define-in-line (SPECIAL-SUBSEQUENT? char) (memq char '(#\. #\+ #\-)))
(define (TOKEN)
(let ((char (next-char)))
(cond ((or (char-whitespace? char) (comment? char))
(token))
((char-alphabetic? char)
(identifier (char-upcase char)))
((char=? char #\")
(string))
((char=? char #\()
token-left-paren)
((char=? char #\))
token-right-paren)
((char=? char #\')
token-quote)
((char=? char #\`)
token-quasiquote)
((char=? char #\,)
(if (char=? (peek-char-port) #\@)
(begin (next-char)
token-unquote-splicing)
token-unquote))
((char=? char #\.)
(cond ((char-numeric? (peek-char-port)) (number char 10 1))
((char-whitespace? (peek-char-port)) token-period)
(else (identifier char))))
((char=? char #\#)
(set! char (char-upcase (next-char)))
(cond ((char=? char #\()
token-vector)
((char=? char #\\ )
(character))
((char=? char #\T)
#t)
((char=? char #\F)
#f)
((char=? char #\B)
(number (next-char) 2 1))
((char=? char #\O)
(number (next-char) 8 1))
((char=? char #\D)
(number (next-char) 10 1))
((char=? char #\X)
(number (next-char) 16 1))
(else (error 'READ "Invalid # option: ~a" char))))
((special-initial? char)
(identifier char))
((char=? char #\\ )
(identifier (next-char)))
((or (eq? char '#\+) (eq? char #\-))
(let ((next (peek-char-port)))
(if (or (char-numeric? next) (memq next '(#\# #\.)))
(number char 0 0)
(identifier char))))
(else (number char 0 0)))))
(define (DELIMITER? char)
(or (eof-object? char)
(char-whitespace? char)
(memq char '(#\( #\) #\" #\;))))
(define (COMMENT? char)
(if (char=? char #\;)
(do () ((char=? (next-char) #\newline) #t))
#f))
;;; When a " is detected, this function is called to read the rest of the
;;; string.
(define (STRING)
(do ((cl '() (cons char cl))
(char (next-char) (next-char)))
((char=? char #\")
(list->string (reverse cl)))
(if (char=? #\\ char) (set! char (next-char)))))
;;; When a #\ is detected, this function is called to read the rest of the
;;; character constant.
(define (CHARACTER)
(let ((char (next-char)))
(if (and (char-alphabetic? char)
(not (delimiter? (peek-char-port))))
(let ((id (identifier (char-upcase char))))
(case id
((tab) (integer->char #o11))
((newline) (integer->char #o12))
((linefeed) (integer->char #o12))
((formfeed) (integer->char #o14))
((return) (integer->char #o15))
((space) (integer->char #o40))
(else (error 'READ "Unrecognized CHARACTER NAME: ~s"
id))))
char)))
;;; When the start of an identifier is detected, the following function is
;;; called to finish reading it. It is table driven from the IDTABLE which
;;; contains an entry for each possible character. The entries are:
;;;
;;; #f character is not part of the identifier.
;;; newchar character is part of the identifier and "newchar" is the
;;; upshifted value.
;;; #t character is \ so the following character is taken as is.
(define IDTABLE
(let ((tab (make-vector 256 #f)))
(do ((i (char->integer #\A) (+ i 1))
(last (char->integer #\Z)))
((> i last))
(vector-set! tab i (integer->char i))
(vector-set! tab (+ i 32) (integer->char i)))
(for-each
(lambda (c)
(vector-set! tab (char->integer c) c))
'(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
; Numeric characters.
#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\~ #\_ #\^
; Special initial.
#\. #\+ #\-)) ; Special subsequent.
(vector-set! tab (char->integer #\\) #t)
tab))
(define (IDENTIFIER firstchar)
(let loop ((cl (list firstchar)))
(let* ((pc (peek-char-port))
(tc (and (char? pc)
(vector-ref idtable (char->integer pc)))))
(cond ((char? tc)
(read-char-port)
(loop (cons tc cl)))
(tc
(read-char-port)
(loop (cons (next-char) cl)))
(else
(string->symbol (list->string (reverse cl))))))))
;;; When the start of a number is detected, the following function is called
;;; to finish reading it.
(define (NUMBER firstchar base sign)
(if (zero? sign)
(cond ((char=? firstchar #\+)
(set! sign 1)
(set! firstchar (next-char)))
((char=? firstchar #\-)
(set! sign -1)
(set! firstchar (next-char)))
(else (set! sign 1))))
(if (zero? base)
(cond ((char=? firstchar #\#)
(let ((char (next-char)))
(case char
((#\B #\b) (set! base 2))
((#\O #\o) (set! base 8))
((#\D #\d) (set! base 10))
((#\X #\x) (set! base 16))
(else (error 'READ "Invalid number base: ~a" char))))
(set! firstchar (next-char)))
(else (set! base 10))))
(do ((cl (list firstchar) (cons char cl))
(char (peek-char-port) (peek-char-port))
(bv (case firstchar ((#\0) 0) ((#\1) 1) (else -1))
(case char ((#\0) (* bv 2)) (( #\1) (+ (* bv 2) 1)) (else -1)))
(iv (accv 0.0 base firstchar) (accv iv base char))
(maxchar (char->integer firstchar) (max maxchar (char->integer char)))
(result (make-string 8))
(pad (make-string 4))
(cs 0)
(fpt (eq? firstchar #\.)
(or fpt
(eq? char #\.)
(and (not (= base 16)) (or (eq? char #\e) (eq? char #\E))))))
((delimiter? char)
(set! cl (list->string (reverse cl)))
(set! cs (string-append (if (eq? sign -1) "-" "") cl ")0"))
(cond (fpt
(if (not (eq? base 10))
(error 'READ "Floating point numbers must be base 10: ~a"
cl))
(if (eq? 2 (sscanf cs "%f)%d" result pad))
(c-double-ref result 0)
(error 'READ "Illegal floating point number: ~a" cl)))
((eq? iv -1)
(error 'READ "Illegal digit(s) in integer: ~a" cl))
(else (let ((siv (* sign iv)))
(if (or (< siv minintf) (> siv maxintf))
siv
(float->fixed siv))))))
(next-char)))
(define (ACCV value base char)
(let ((cv (assq char '((#\0 0) (#\1 1) (#\2 2) (#\3 3)
(#\4 4) (#\5 5) (#\6 6) (#\7 7)
(#\8 8) (#\9 9) (#\a 10) (#\b 11)
(#\c 12) (#\d 13) (#\e 14) (#\f 15)
(#\A 10) (#\B 11) (#\C 12) (#\D 13)
(#\E 14) (#\F 15)))))
(if (or (eq? value -1) (not cv) (>= (cadr cv) base))
-1
(+ (* base value) (cadr cv)))))
;;; 7.1.2. External Representations
(define (READ-DATUM port-proc)
(let ((save-peek-char-port peek-char-port)
(save-read-char-port read-char-port))
(set! peek-char-port (port-proc 'peek-char))
(set! read-char-port (port-proc 'read-char))
(let ((result (let loop ((char (peek-char-port)))
(cond ((eof-object? char)
(read-char-port))
((char-whitespace? char)
(read-char-port)
(loop (peek-char-port)))
((char=? char #\;)
(do () ((char=? (next-char) #\newline)))
(loop (peek-char-port)))
(else (datum (token)))))))
(set! peek-char-port save-peek-char-port)
(set! read-char-port save-read-char-port)
result)))
(define (DATUM current-token)
(cond ((eq? current-token token-left-paren)
(datum-list (token)))
((eq? current-token token-vector)
(list->vector (datum-vector (token))))
((eq? current-token token-quote)
(list 'quote (datum (token))))
((eq? current-token token-quasiquote)
(list 'quasiquote (datum (token))))
((eq? current-token token-unquote)
(list 'unquote (datum (token))))
((eq? current-token token-unquote-splicing)
(list 'unquote-splicing (datum (token))))
((not (pair? current-token))
current-token)
(else (error 'READ "Poorly formed DATUM: ~s" current-token))))
(define (DATUM-LIST current-token)
(cond ((eq? current-token token-right-paren)
'())
((eq? current-token token-period)
(let ((result (datum (token))))
(if (eq? (token) token-right-paren)
result
(error 'READ "Poorly formed LIST"))))
(else
(cons (datum current-token) (datum-list (token))))))
(define (DATUM-VECTOR current-token)
(cond ((eq? current-token token-right-paren)
'())
(else
(cons (datum current-token)
(datum-vector (token))))))
;;; Method for printing a token is cached here.
(define WRITE-TOKEN-PORT '())
(define (WRITE/DISPLAY obj readable port-proc)
(let ((save-write-token-port write-token-port))
(set! write-token-port (port-proc 'write-token))
(let ((result (write/display2 obj readable)))
(set! write-token-port save-write-token-port)
result)))
(define (WRITE/DISPLAY2 obj readable)
(cond ((pair? obj)
(let ((qq (and (pair? (cdr obj)) (null? (cddr obj))
(assq (car obj)
'((quote "'") (quasiquote "`")
(unquote ",") (unquote-splicing ",@"))))))
(cond ((and qq readable)
(write-token-port (cadr qq))
(write/display2 (cadr obj) readable))
(else
(write-token-port "(")
(write/display2 (car obj) readable)
(write/display-list (cdr obj) readable)))))
((symbol? obj)
(if readable
(if (memq obj '(+ - ))
(write-token-port (symbol->string obj))
(write-token-port (readable-symbol obj)))
(write-token-port (symbol->string obj))))
((fixed? obj)
(write-token-port (fixed->clist obj)))
((string? obj)
(write-token-port (if readable (readable-string obj) obj)))
((char? obj)
(write-token-port (if readable (readable-char obj) obj)))
((or (string? obj) (char? obj))
(write-token-port obj))
((vector? obj)
(write-token-port "#")
(write/display2 (vector->list obj) readable))
((float? obj)
(write-token-port (float->clist obj)))
((eq? obj #t)
(write-token-port "#T"))
((eq? obj #f)
(write-token-port "#F"))
((null? obj)
(write-token-port "()"))
((eof-object? obj)
(write-token-port "#*END-OF-FILE*"))
((eq? obj undefined)
(write-token-port "#*UNDEFINED*"))
((procedure? obj)
(write-token-port "#*PROCEDURE*"))
(else (write-token-port "#*??????*"))))
(define (WRITE/DISPLAY-LIST obj readable)
(cond ((null? obj)
(write-token-port ")"))
((not (pair? obj))
(write-token-port " . ")
(write/display2 obj readable)
(write-token-port ")"))
(else
(write-token-port " ")
(write/display2 (car obj) readable)
(write/display-list (cdr obj) readable))))
(define (READABLE-CHAR obj)
(if (and (char>? obj #\space) (char<=? obj #\~))
(list->string (list #\# #\\ obj))
(let ((spec (assoc obj '((#\tab "#\\tab")
(#\newline "#\\newline")
(#\linefeed "#\\linefeed")
(#\formfeed "#\\formfeed")
(#\return "#\\return")
(#\space "#\\space")))))
(if spec
(cadr spec)
"#\\???"))))
(define (READABLE-STRING obj)
(do ((cl '(#\") (cons (string-ref obj i) cl))
(len (string-length obj))
(i 0 (+ i 1)))
((= len i) (reverse (cons #\" cl)))
(if (and (or (eq? (string-ref obj i) #\\ )
(eq? (string-ref obj i) #\" )))
(set! cl (cons #\\ cl)))))
(define (READABLE-SYMBOL obj)
(set! obj (symbol->string obj))
(do ((cl '() (cons (string-ref obj i) cl))
(len (string-length obj))
(i 0 (+ 1 i)))
((= i len) (reverse cl))
(let ((c (string-ref obj i)))
(cond ((and (not (and (char-alphabetic? c) (char-upper-case? c)))
(not (special-initial? c))
(not (special-subsequent? c))
(not (char-numeric? c)))
(set! cl (cons #\\ cl)))
((and (zero? i) (not (char-alphabetic? c))
(not (special-initial? c)))
(set! cl (cons #\\ cl)))))))
(define (FIXED->CLIST obj)
(do ((cl '() (cons (integer->char (+ (char->integer #\0)
(abs (remainder number 10))))
cl))
(number obj (quotient number 10)))
((and (zero? number) cl)
(if (< obj 0) (cons #\- cl) cl))))
(define (FLOAT->CLIST obj)
(let* ((null (integer->char 0))
(buffer (make-string 30 null)))
(gcvt obj 16 buffer)
(let loop ((cli (string->list buffer)) (clo '()))
(if (eq? (car cli) null)
(reverse (if (or (memq #\. clo) (memq #\e clo))
clo
(cons #\. clo)))
(loop (cdr cli) (cons (car cli) clo))))))